home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / extras0.em < prev    next >
Lisp/Scheme  |  1992-10-07  |  7KB  |  276 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: extras0.em
  4. ;; Date: Fri Jan 10 04:17:12 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule extras0
  11.   (ccc lists list-operators others arith calls macros0 tables
  12.        (except (null) class-names)
  13.        classes
  14.        symbols
  15.        formatted-io
  16.        generics
  17.        vectors
  18.        strings
  19.        ) ()
  20.  
  21.   (defun not (widget) (null widget))
  22.  
  23.   (export not)
  24.  
  25.   (defun caar (x) (car (car x)))
  26.   (defun cadr (x) (car (cdr x)))
  27.   (defun cdar (x) (cdr (car x)))
  28.   (defun cddr (x) (cdr (cdr x)))
  29.  
  30.   (export caar cadr cdar cddr)
  31.  
  32.   (defun caaar (x) (car (car (car x))))
  33.   (defun caadr (x) (car (car (cdr x))))
  34.   (defun cadar (x) (car (cdr (car x))))
  35.   (defun caddr (x) (car (cdr (cdr x))))
  36.   (defun cdaar (x) (cdr (car (car x))))
  37.   (defun cdadr (x) (cdr (car (cdr x))))
  38.   (defun cddar (x) (cdr (cdr (car x))))
  39.   (defun cdddr (x) (cdr (cdr (cdr x))))
  40.  
  41.   (export caaar caadr cadar caddr cdaar cdadr cddar cdddr)
  42.  
  43.   (defun caaaar (x) (car (car (car (car x)))) )
  44.   (defun caaadr (x) (car (car (car (cdr x)))) )
  45.   (defun caadar (x) (car (car (cdr (car x)))) )
  46.   (defun caaddr (x) (car (car (cdr (cdr x)))) )
  47.   (defun cadaar (x) (car (cdr (car (car x)))) )
  48.   (defun cadadr (x) (car (cdr (car (cdr x)))) )
  49.   (defun caddar (x) (car (cdr (cdr (car x)))) )
  50.   (defun cadddr (x) (car (cdr (cdr (cdr x)))) )
  51.   (defun cdaaar (x) (cdr (car (car (car x)))) )
  52.   (defun cdaadr (x) (cdr (car (car (cdr x)))) )
  53.   (defun cdadar (x) (cdr (car (cdr (car x)))) )
  54.   (defun cdaddr (x) (cdr (car (cdr (cdr x)))) )
  55.   (defun cddaar (x) (cdr (cdr (car (car x)))) )
  56.   (defun cddadr (x) (cdr (cdr (car (cdr x)))) )
  57.   (defun cdddar (x) (cdr (cdr (cdr (car x)))) )
  58.   (defun cddddr (x) (cdr (cdr (cdr (cdr x)))) )
  59.  
  60.   (export caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr 
  61.       cdaaar cdaadr cdadar cdaddr cddaar cdddar cddadr cddddr)
  62.  
  63.   (defun eqcar (a b) (cond ((atom a) nil) ((eq (car a) b) t) (t nil)))
  64.  
  65.   (export eqcar)
  66.  
  67.   (defun mkquote (x) (list 'quote x))
  68.  
  69.   (export mkquote)
  70.  
  71.   (defun assq (a l)
  72.     (cond
  73.      ((null l) nil)
  74.      ((eq a (caar l)) (car l))
  75.      (t (assq a (cdr l)))) )
  76.  
  77.   (export assq)
  78.  
  79.   (defun list-ref (l n)
  80.     (if (equal n 0) (car l)
  81.       (list-ref (cdr l) (\- n 1))))
  82.  
  83.   (export list-ref)
  84.  
  85.   (defun \@list-ref-update\@ (l n obj)
  86.     (if (equal n 0) ((setter car) l obj)
  87.       (\@list-ref-update\@ (cdr l) (- n 1) obj)))
  88.  
  89.   (defun reverse (l)
  90.     (reverse-aux l nil))
  91.  
  92.   (defun reverse-aux (l so-far)
  93.     (if l (reverse-aux (cdr l)
  94.              (cons (car l) so-far))
  95.       so-far))
  96.  
  97.   ;;  (defun reverse (l)
  98.   ;;    (labels ((rev1 (l n)
  99.   ;;           (if (null l) n
  100.   ;;             (rev1 (cdr l) (cons (car l) n)))))
  101.   ;;        (rev1 l nil)))
  102.  
  103.   (export reverse)
  104.  
  105.   (defun subst (a b c)
  106.     (cond
  107.      ((equal c b) a)
  108.      ((atom c) c)
  109.      (t 
  110.       ((lambda (carc cdrc)
  111.      (cond ((and (eq carc (car c)) (eq cdrc (cdr c))) c)
  112.            (t (cons carc cdrc))))
  113.        (subst a b (car c))
  114.        (subst a b (cdr c))))))
  115.  
  116.   (export subst)
  117.  
  118.   (defun delete (a b comp)
  119.     (cond
  120.      ((null b) nil)
  121.      ((comp a (car b)) (cdr b))
  122.      (t ((lambda (del)
  123.        (cond ((eq del (cdr b)) b)
  124.          (t (cons (car b) del))))
  125.      (delete a (cdr b) comp)))))
  126.  
  127.   (export delete)
  128.  
  129.   (defun deleteq (a b)
  130.     (cond
  131.      ((null b) nil)
  132.      ((eq a (car b)) (cdr b))
  133.      (t ((lambda (del)
  134.        (cond ((eq del (cdr b)) b)
  135.          (t (cons (car b) del))))
  136.      (deleteq a (cdr b))))))
  137.  
  138.   (export deleteq)
  139.  
  140.   ;; Control Extentions - Exit Extentions
  141.   (defmacro block forms (cons 'let/cc forms))
  142.  
  143.   (defmacro return-from (name . forms)
  144.     (list name (cons 'progn forms)))
  145.  
  146.   (export block return-from)
  147.  
  148.   (defmacro catch (tag . body)
  149.     `(let/cc \@
  150.          (dynamic-let ((,tag \@)) ,@body)))
  151.  
  152.   (defmacro throw (tag . forms)
  153.     `((dynamic ,tag) (progn ,@forms)))
  154.  
  155.   (export catch throw)
  156.  
  157.   (defmacro prog1 forms
  158.     `((lambda (@prog1-handle@)
  159.     ,@(cdr forms)
  160.     @prog1-handle@) ,(car forms)))
  161.  
  162.   (export prog1)
  163.  
  164.   ;;
  165.   ;; Missing bits...
  166.   ;;
  167.  
  168.   (defun negativep (i) (binary-lt i 0))
  169.  
  170.   (export negativep)
  171.  
  172.   (defun list-copy-aux (l new)
  173.     (if l (list-copy-aux (cdr l) (nconc new (cons (car l) nil)))
  174.       new))
  175.  
  176.   (defun list-copy (l) (list-copy-aux l nil))
  177.  
  178.   (export list-copy)
  179.  
  180.   ;
  181.   ;; Multiple Values.
  182.   ;;
  183.   ;;  An el-cheapo pseudo implementation.
  184.   ;
  185.  
  186.   (defmacro values forms
  187.     (if (null (cdr forms)) forms
  188.       `(list ,@forms)))
  189.  
  190.   (defun call/mv (f values) (apply f values))
  191.  
  192.   (defmacro let/mv (vars form . body)
  193.     `(call/mv (lambda ,vars ,@body) ,form))
  194.  
  195.   (export values call/mv let/mv)
  196.  
  197.   ;; Conversion
  198.   ;; According to the standard (nearly)
  199.  
  200.   (defconstant *convert-tab* (make-table eq))
  201.  
  202.   (defun converter (class)
  203.     (let ((xx (table-ref *convert-tab* class)))
  204.       (if (not (null xx))
  205.       xx
  206.     (let ((new-gen (make-converter-generic class)))
  207.       ((setter converter) class new-gen)
  208.       new-gen))))
  209.       
  210.   (defun make-converter-generic (class)
  211.     (make-instance generic-function
  212.            'name (make-symbol (format nil "~a-converter" (class-name class)))
  213.            'lambda-list '(a)
  214.            'method-class method))
  215.   
  216.   ((setter setter) converter
  217.    (lambda (class fn)
  218.      ((setter table-ref) *convert-tab* class fn)))
  219.   
  220.   
  221.   (defun convert (x class)
  222.     ((converter class) x))
  223.   
  224.   (export converter convert)
  225.   ;; shove in the defined methods...
  226.   ;; Really so trivial that we could use lisp functions...
  227.  
  228.   (add-method (converter vector)
  229.           (make-instance method
  230.                  'signature (list pair)
  231.                  'function generic_generic_convert\,Cons\,Vector))
  232.  
  233.   (add-method (converter vector)
  234.           (make-instance method
  235.                  'signature (list (class-of nil))
  236.                  'function (lambda (a b c)
  237.                      (make-vector 0))))
  238.  
  239.   (add-method (converter pair)
  240.           (make-instance method 
  241.                  'signature (list vector)
  242.                  'function generic_generic_convert\,Vector\,Cons))
  243.  
  244.   (add-method (converter string)
  245.           (make-instance method 
  246.                  'signature (list object)
  247.                  'function (lambda (h1 h2 obj)
  248.                      (format nil "~a" obj))))
  249.  
  250.   ;; Also need to add:
  251.   ;; (allsorts) number from string
  252.   ;; char<-->int
  253.   ;; string->pair
  254.  
  255.   (defconstant length (make-instance generic-function 
  256.                      'name 'length
  257.                      'lambda-list '(l)
  258.                      'method-class method))
  259.  
  260.   (add-method length (make-instance method
  261.                     'signature (list pair)
  262.                     'function list-length))
  263.  
  264.   (add-method length (make-instance method 
  265.                     'signature (list vector)
  266.                     'function vector-length))
  267.  
  268.   ;; commented out 'cos there ain't one.
  269.   (add-method length (make-instance method
  270.                     'signature (list string)
  271.                     'function string-length))
  272.  
  273.   (export length)
  274.   
  275. )
  276.